perm filename EMACLS.16[MAC,LSP]2 blob
sn#622713 filedate 1981-11-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00026 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MacLisp portion of the E/MacLisp Interface.
C00022 00003 E Manipulation Routines
C00028 00004 Routines to queue up mail
C00030 00005 αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
C00039 00006 Mail Interface
C00043 00007 Mail Type
C00048 00008 Wait Mail
C00051 00009 Mask Routines
C00053 00010 Mail SFA
C00057 00011 Tyi
C00060 00012 Tyo
C00062 00013 Force Output
C00066 00014 Message Align
C00068 00015 Mail Refresh
C00073 00016 Transfer Buffer
C00078 00017 Clear Input
C00079 00018 Wait OK
C00082 00019 Send Simple Message
C00086 00020 Em:init
C00090 00021 Send OK
C00091 00022 Em:eval-protect
C00092 00023 Mail queue
C00095 00024 Readonly Variables
C00101 00025 Random debugging stuff
C00104 00026 Storage for Mail routines
C00107 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
;;; Starts with si:ejobnum figured out from E.
;;; (sfa-call <sfa> 'send-lines n)
;;; sets the number of lines that are sent at one time to n.
;;; normal is T (meaning send every line).
;;; NIL means never send.
;;; (sfa-call <sfa> 'report-send-lines) returns the value
;;; si:ecalledp, the global variable, tells whether E called you
;;; History
(declare (mapex t)
; (setq defmacro-for-compiling ())
(special -em:ecommands- -em:sfa- -em:errorp-
-em:oldtyi- -em:oldtyo- -em:mode- -em:silence-
-em:mail-input-buffer-dry-handler- -em:queue- -em:lqueue-
-em:herald- -em:cmchar-table- -em:si:ecalledp- si:ejobnum
si:sail-mail-service
-em:filemode- -em:linel-)
(*expr em:get-next-readonly em:force-readonly-message em:make-sixbit
em:readonly-init em:warn em:message-align em:send-simple-message
em:mail-sfa em:init-send-lines em:init em:get-jobnum em:set-jobnum
em:turn-mask-off em:business-address em:mail-interrupt-handler
em:mask-on em:eval-protect em:mask-off)
(*lexpr em:fread %match)
(fixnum si:ejobnum))
(setq -em:ecommands- ()
-em:mail-input-buffer-dry-handler- ()
-em:mode- 'LTYPE
-em:si:ecalledp- ()
-em:oldtyi- tyi -em:oldtyo- tyo
-em:filemode- ()
-em:cmchar-table- ()
-em:herald- '|MacLisp Ready|
-em:silence- ()
-em:linel- (linel t))
(defun em:mail-interface-initialize ()
(em:turn-mask-off)
(setq -em:queue- ())
(setq -em:lqueue- ())
(em:initialize)
(setq -em:si:ecalledp- t)
(and -em:herald-
(progn (princ -em:herald-)(terpri)))
(sfa-call -em:sfa- 'force-output ())
(setq si:sail-mail-service 'em:mail-interrupt-handler)
)
(setq -em:sfa- ())
(sstatus ttyint 232. '+internal-↑B-break)
(sstatus ttyint 200. '+internal-↑B-break)
(defun em:initialize ()
(em:get-jobnum)
(em:init)
(em:init-send-lines)
(setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
(setq tyi -em:sfa-)
(setq tyo -em:sfa-)
(setq msgfiles `(,-em:sfa-))
(sfa-store -em:sfa- 'xcons -em:sfa-)
(em:send-simple-message 'ok)
)
(defun em:connect (n)
(em:set-jobnum n)
(em:init)
(em:init-send-lines)
(setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
(setq tyi -em:sfa-)
(setq tyo -em:sfa-)
(setq msgfiles `(,-em:sfa-))
(sfa-store -em:sfa- 'xcons -em:sfa-)
(em:send-simple-message 'ok)
)
(defmacro unascii (x)
`(car (exploden ,x)))
(defun em:ecommands (l)
(sfa-call -em:sfa- 'force-output ())
(let ((-em:ecommands- t))
(do ((com l (cdr com)))
((null com)(sfa-call -em:sfa- 'force-output ()))
(cond ((eq (car com) '<cr>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o27))
((eq (car com) '<lf>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o1))
((eq (car com) '<sp>)
(sfa-call -em:sfa- 'tyo '32.))
((eq (car com) '<bs>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o102))
((eq (car com) '<tab>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o75))
((eq (car com) '<⊗>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o26))
((eq (car com) '<alt>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o33))
(t
(sfa-call -em:sfa- 'tyo
(unascii (car com))))))))
;;; Like above, but takes ascii codes
(defun em:raw-ecommands (l)
(sfa-call -em:sfa- 'force-output ())
(let ((-em:ecommands- t))
(do ((com l (cdr com)))
((null com)(sfa-call -em:sfa- 'force-output ()))
(cond ((= (car com) #o11)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o75))
((= (car com) #o175)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o33))
(t
(sfa-call -em:sfa- 'tyo
(cond ((= (car com) #o15) #o26)
((= (car com) #o12) #o27)
(t (car com)))))))))
(defun em:set-send-lines (n)
(sfa-call -em:sfa- 'send-lines n))
(defun em:get-send-lines ()
(sfa-call -em:sfa- 'report-send-lines ()))
(defun em:force ()
(sfa-call -em:sfa- 'force-output ()))
;(setq read-eval-print-* 'em:terpri)
(defun em:terpri () (terpri -em:sfa-))
(defun em:real-terpri () (tyo #o40 -em:sfa-)(terpri -em:sfa-))
(defun em:eval-message ()
((lambda (eof)
(em:message-align)(em:set-send-lines t)
(do ((form (em:fread eof) (em:fread eof))
(l nil))
((eq form eof)
(do ((i (nreverse l) (cdr i)))
((null i)
(sfa-call -em:sfa- 'force-output ())
(em:set-send-lines ()))
(print (car i))))
(setq l (cons (eval form) l)))) (ncons ())))
(defun em:eval-message-warn ()
((lambda (eof)
(em:message-align)(em:set-send-lines t)
(do ((form (em:fread eof) (em:fread eof))
(l nil))
((eq form eof)
(em:warn '|Done!|)
(do ((i (nreverse l) (cdr i)))
((null i)
(sfa-call -em:sfa- 'force-output ())
(em:set-send-lines ()))
(print (car i))))
(setq l (cons (eval form) l)))) (ncons ())))
(defmacro em:read-until-eof (form return . forms)
`((lambda (eof)
(em:message-align)
(do ((,form (em:fread eof) (em:fread eof)))
((eq ,form eof) ,return)
. ,forms)) (ncons ())))
(defmacro em:tyi-until-eof (form return . forms)
`((lambda (-em:filemode-)
(em:message-align)
(do ((,form (tyi -em:sfa- -1) (tyi -em:sfa- -1)))
((= ,form -1) ,return)
. ,forms)) t))
(defun em:tyi-message ()
(let ((ans ()))
(em:tyi-until-eof form (nreverse ans)
(push form ans))))
(defun em:fread n
((lambda (-em:filemode-)
(cond ((zerop n)
(read))
((= n 1)
(read (arg 1)))
((= n 2)
(read (arg 1)(arg 2)))
(t
(break |too many args to FREAD| t))))
t))
(defun em:control-dispatch (char)
(cond ((member char '(#o302 #o342))
(funcall '+internal-↑B-break -em:sfa- char))
((member char '(#o307 #o347))
(↑G))
((member char '(#o303 #o343))
(setq ↑D ()))
((member char '(#o304 #o344))
(setq ↑D t))
(t ((lambda (fun)
(cond (fun (funcall fun -em:sfa- char))
((setq fun (cdr (assoc char
-em:cmchar-table-)))
(funcall fun char) char)
(t char)))
(status ttyint char)))))
(defun em:readonly-vars (l)
;make up message and initial (sixbit . ascii) alist
(em:readonly-init)
(cond ((> (length l) 25.)
(do ((rest l (cdr rest))
(i 25. (1- i))
(first25 ()))
((= i 0)
(append
(em:readonly-vars first25)
(em:readonly-vars rest)))
(push (car l) first25)))
(t
(setq l
(mapcar #'(lambda (x)
(subst () ()
`(,(em:make-sixbit x)
,x () ())))
l))
(em:force-readonly-message)
(do ((nxt (em:get-next-readonly)
(em:get-next-readonly))
(entry))
((equal nxt -1)
(mapcan #'(lambda (x)
(cond
((caddr x)
`((,(cadr x) . ,(cadddr x))))))
l))
(cond ((setq entry (assoc (car nxt) l))
(rplaca (cdddr entry) (cdr nxt))
(rplaca (cddr entry) t)))))))
(declare (special em:line em:lines em:page em:pages))
(defun em:send-next-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((= em:lines em:line)
(cond ((= em:page em:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq em:line 1
em:page (1+ em:page)
em:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(⊗ ↔ α =))
(setq em:line (1+ em:line))))))
(defun em:send-this-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((< em:lines em:line)
(cond ((= em:page em:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq em:line 1
em:page (1+ em:page)
em:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(α = ⊗ ↔))
(setq em:line (1+ em:line))))))
;;; SEXP on next line
(defun em:eval-next-sexp ()
(em:ecommands '(α β - α β V))
(em:eval-next-sexp1)
(em:ecommands '(α β V)))
(defun em:eval-next-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq em:line (cdr (assq 'line alist))
em:lines (cdr (assq 'lines alist))
em:page (cdr (assq 'page alist))
em:pages (cdr (assq 'pages alist))))
(let ((-em:mail-input-buffer-dry-handler- 'em:send-next-line))
(print (eval (read)))))
;;; SEXP on this line
(defun em:eval-this-sexp ()
(em:ecommands '(α β - α β V))
(em:eval-this-sexp1)
(em:ecommands '(α β V)))
(defun em:eval-this-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq em:line (cdr (assq 'line alist))
em:lines (cdr (assq 'lines alist))
em:page (cdr (assq 'page alist))
em:pages (cdr (assq 'pages alist))))
(cond ((< em:lines em:line)(setq em:line (1- em:line))
(em:ecommands '(⊗ ↑))))
(let ((-em:mail-input-buffer-dry-handler- 'em:send-this-line))
(print (eval (read)))))
(defun em:add-cmfun (char fun)
(push `(,char . ,fun) -em:cmchar-table-))
(defun em:delete-cmfun (char)
(setq -em:cmchar-table-
(mapcan
#'(lambda (x)
(cond ((= char (car x)) ())
(t (ncons x))))
-em:cmchar-table-)))
(defun em:ttyint (l)
(let ((entry (assoc (car l) -em:cmchar-table-)))
(cond ((cadr l)
(cond (entry (rplacd entry (cadr l))
(cadr l))
(t (em:add-cmfun (car l)(cadr l)))))
(t (cdr entry)))))
(defun em:transcript-read n
((lambda (form)
(print form)
form)
(apply 'read (listify n))))
(defun em:transcript-off (() ()) (em:transcript ()))
(defun em:transcript (flag)
(cond (flag (setq read 'em:transcript-read)
(em:ecommands '(α X L F I L E ⊗ ↔ α X E V A L ⊗ ↔ ))
(setq -em:mode- 'LFILE)
(em:swallow-alt)
'TRANSCRIPT)
(t (em:ecommands '(α X l t y p e ⊗ ↔))
(setq -em:mode- 'LTYPE)
(setq read ()))))
(defun em:swallow-alt ()
(do ((i (tyi)(tyi)))
((= i #o175) t)))
(defun em:mode (mode) (setq -em:mode- mode))
(defun em:lfile-mode () (setq -em:mode- 'lfile)
(em:ecommands
'(α X L F I L E ⊗ ↔ α X S A Y | | L F I L E | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:ltype-mode () (setq -em:mode- 'ltype)
(em:ecommands
'(α X L T Y P E ⊗ ↔ α X S A Y | | L T Y P E | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:lattach-mode () (setq -em:mode- 'lattach)
(em:ecommands
'(α X L A T T A C H ⊗ ↔ α X S A Y | | L A T T A C H | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:lpend-mode () (setq -em:mode- 'lfile)
(em:ecommands
'(α X L P E N D ⊗ ↔ α X S A Y | | L P E N D | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:readonly-var (var)
(cdr (assq var (em:readonly-vars `(,var)))))
;;; E Manipulation Routines
;;; These are to help the user edit his MacLisp file.
;;; This routine sends the current sexp no matter where you
;;; are as long as you are `inside' of it
(defun em:send-this-defun ()
(em:ecommands '(α β - α β V))
(em:find-defun-backwards);find the previous defun, defmacro...
(em:eval-this-sexp1) ;evaluate it
(em:ecommands '(α β V)))
(defun em:find-defun-backwards ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq em:line (cdr (assq 'line alist))
em:lines (cdr (assq 'lines alist))
em:page (cdr (assq 'page alist))
em:pages (cdr (assq 'pages alist)))
(cond ((< em:lines em:line)(setq em:line (1- em:line))
(em:ecommands '(⊗ ↑))))
(*catch 'em:find-defun-backwards
(do ((em:page em:page (1- em:page)))
((< em:page 1) (break |Defun not found| t))
(do ((em:line em:line (1- em:line)))
((< em:line 1))
(em:ecommands '(α =))
(cond ((em:defun-on-this-linep (em:tyi-message))
(*throw 'em:find-defun-backwards t)))
(em:ecommands '(⊗ b)))
(em:ecommands '(α - α p α ∞ ⊗ ↔ ⊗ b))
(setq em:lines (cdr (assq 'lines (em:readonly-vars '(lines)))))
(setq em:line em:lines)))))
;;; For now it looks for:
;;; (defun
;;; (defmacro
;;; (macro
;;; (match-macro
;;; (macrodef
(defun em:defun-on-this-linep (text)
(or
(%match '(* #o50 ($ir * em:spacep)
($r ? em:dp)
($r ? em:ep)
($r ? em:fp)
($r ? em:up)
($r ? em:np) ($r ? em:spacep) *) text)
(%match '(* #o50 ($ir * em:spacep)
($r ? em:dp)
($r ? em:ep)
($r ? em:fp)
($r ? em:mp)
($r ? em:ap)
($r ? em:cp)
($r ? em:rp)
($r ? em:op) ($r ? em:spacep) *) text)
(%match '(* #o50 ($ir * em:spacep)
($r ? em:mp)
($r ? em:ap)
($r ? em:tp)
($r ? em:cp)
($r ? em:hp)
($r ? em:-p)
($r ? em:mp)
($r ? em:ap)
($r ? em:cp)
($r ? em:rp)
($r ? em:op) ($r ? em:spacep) *) text)
(%match '(* #o50 ($ir * em:spacep)
($r ? em:mp)
($r ? em:ap)
($r ? em:cp)
($r ? em:rp)
($r ? em:op)
($r ? em:dp)
($r ? em:ep)
($r ? em:fp) ($r ? em:spacep) *) text)
(%match '(* #o50 ($ir * em:spacep)
($r ? em:mp)
($r ? em:ap)
($r ? em:cp)
($r ? em:rp)
($r ? em:op) ($r ? em:spacep) *) text)))
(defun em:spacep (n) (or (= n #o40)
(= n #o11)))
(defun em:dp (n) (or (= n #o104)
(= n #o144)))
(defun em:ep (n) (or (= n #o105)
(= n #o145)))
(defun em:fp (n) (or (= n #o106)
(= n #o146)))
(defun em:up (n) (or (= n #o125)
(= n #o165)))
(defun em:np (n) (or (= n #o116)
(= n #o156)))
(defun em:mp (n) (or (= n #o115)
(= n #o155)))
(defun em:ap (n) (or (= n #o101)
(= n #o141)))
(defun em:cp (n) (or (= n #o103)
(= n #o143)))
(defun em:rp (n) (or (= n #o122)
(= n #o162)))
(defun em:op (n) (or (= n #o117)
(= n #o157)))
(defun em:tp (n) (or (= n #o124)
(= n #o164)))
(defun em:hp (n) (or (= n #o110)
(= n #o150)))
(defun em:-p (n) (= n #o55))
;;; Routines to queue up mail
;;; The queue is an ALIST of array, business address pairs
(defun em:add-queue ()
(let ((ar (*array () 'fixnum 32.)))
(setq -em:queue-
(nconc -em:queue- `(,ar )))
(em:business-address (maknum ar))))
(defun em:get-queue ()
(cond (-em:queue-
(prog2 ()
(em:business-address
(maknum (car -em:queue-)))
(setq -em:queue- (cdr -em:queue-))))))
(defun em:get-lqueue ()
(cond (-em:lqueue-
(prog2 ()
(em:business-address
(maknum (car -em:lqueue-)))
(setq -em:lqueue- (cdr -em:lqueue-))))))
(defun em:add-lqueue (n)
(let ((ar (*array () 'fixnum (+ 1 n))))
(setq -em:lqueue-
(nconc -em:lqueue- `(,ar )))
(em:business-address (maknum ar))))
;;; αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
;;; αnαxSLISP talks to job n(10.)
;;; α0αxSLISP types the wholine of inferior
;;; α-αxSLISP murder (i.e. negotiated suicide)
;;; α= send arrow line or attach buffer
;;; α+nα= send next n lines
;;; α-nα= send previous n lines
;;; αx= <sexp>
;;; send comand line
;;;
;;; Protocols: (* means not actually anticipated to be used; current
;;; implementation knows about it but does not send and/or interpret them
;;; specially)
;;;
;;; From E to MacLisp
;;; Mail
;;; wd0: Job# sending message
;;; wd1: type of message
;;;
;;; 2,,0: Continuation needed
;;; 1,,0: Short (fits in the next =30 words, ends with null byte
;;; or falls off)
;;;
;;; 0 no-op
;;; 1 initiating a conversation
;;; 2 ok (did the jobread)
;;; 3 SEXPs
;;; 4 explicit eof
;;; 5 control (meta) chars to follow (E macro format)
;;; (or E commands (from MacLisp to E))
;;; 6 interrupt. do <esc>i <char>
;;; 7 close connection (suicide)
;;; 8 readonly variables
;;;
;;; wd2: -number of bytes,,address of buffer
;;;
;;;
;;; E commands will be represented in the standard E macro manner
;;; (unless there is something better).
;;;
;;;
;;; Protocol is:
;;; E MacLisp
;;; ---------------
;;; initiate
;;; ok
;;;
;;; To send a short message just a MAIL
;;; To send a long message MAIL then wait for JOBREAD acknowledge
;;; To send interrupts, just send them
;;; Acknowledgment is the short OK message
;;;
;;; Commands needed:
;;; start DMP file
;;; send control chars
;;; send interrupt character (just 1 at a time)
;;;
;;; Mail Interface
(lap em:MAIL-interface subr)
(defsym rovmailblksize 50.)
(defsym mlblksize 32.)
(defsym freeac #o13)
(defsym cntrl-bit #o200)
(defsym meta-bit #o400)
(defsym ccntrlg #o307)
(defsym cntrlg #o347)
(defsym ccntrlx #o330)
(defsym cntrlx #o370)
(defsym EPR #o456062)
(defsym noutbytes #o12000)
(defsym nrovbytes #o1000)
(defsym rdblk #o2000)
(defsym blksize #o2000)
(defsym maxshort 145.)
(defsym rovmaxshort 29.)
(defsym noop-type 0)
(defsym initiate-type 1)
(defsym ok-type 2)
(defsym sexp-type 3)
(defsym explicit-eof-type 4)
(defsym ecommand-type 5)
(defsym interrupt-type 6)
(defsym kill-type 7)
(defsym readonlyvar-type 8.)
(defsym high-command 8.)
(defsym bs #o177)
(defsym lf #o12)
(defsym cr #o15)
(defsym space #o40)
(defsym tab #o11)
(defsym alpha 2)
(defsym beta 3)
(defsym cont-bit 2)
(defsym short-bit 1)
(defsym meta-mask 400)
(defsym control-mask 200)
;;; Silly jobnum was never set
setjob (movem tt ijobnum)
(movem tt ojobnum)
(movem tt o2jobnum)
(movem tt jobread)
(movem tt ljobread)
(jsp t fxcons) ;number cons
(movem a (special si:ejobnum)) ;save it
(popj p)
true (movei a 't)
(popj p)
false (movei a 'nil)
(popj p)
pfxpfalse
(pop fxp tt)
; (pushj p poptt4)
(pushj p send-ok)
(jrst 0 false)
(entry em:get-jobnum subr)
(args em:get-jobnum (nil . 0))
(move tt (special si:ejobnum))
(movem tt ijobnum)
(movem tt ojobnum)
(movem tt o2jobnum)
(movem tt jobread)
(movem tt ljobread)
(jsp t fxcons)
(movem a (special si:ejobnum))
(jrst 0 em:get-terminal)
(entry em:set-jobnum subr)
(args em:set-jobnum (nil . 1))
(move tt 0 a)
(movem tt ijobnum)
(movem a (special si:ejobnum))
(movem tt jobread)
(movem tt ljobread)
(movem tt ojobnum)
(movem tt o2jobnum)
(popj p)
wrongj (movei a 'wrong-jobnum)
(popj p)
;;; Mail Type
(entry em:process-mail subr)
em:process-mail
; (setzm 0 tyi-inited)
(entry em:mail-type subr)
(args em:mail-type (nil . 0))
em:mail-type
(setzm 0 explicit-eof) ;0 means nil
(setzm 0 forcedp)
(move tt (+ imailbox 1));type bits
(setzm 0 contp)
(tlne tt cont-bit)
(setom 0 contp)
(hrrzs 0 tt) ;grumble, test for range
(skipge 0 tt) ;too low?
(jrst 0 unknown) ;yup, unknown
(caile tt high-command) ;too high
(jrst 0 unknown)
(jrst 0 @ type-disp tt) ;dispatch
unknown (movei a 'unknown)
(popj p)
type-disp
(0 0 no-op)
(0 0 initiate)
(0 0 ok)
(0 0 sexps)
(0 0 explicit-eof)
(0 0 e-command)
(0 0 interrupt)
(0 0 kill)
(0 0 readonlyvars)
e-command
(movei a 'ecommand)
(popj p)
no-op
(movei a 'no-op)
(popj p)
sexps
(move a (+ imailbox 2)) ;get number of bytes
(move tt (+ imailbox 1)) ;type bits
; (setzm 0 tyi-inited) ;tyi not inited
(hlrem a inbytes) ;store it
(hlre b a) ;-number of bytes
(idivi b 4) ;-number of words
(jumpe c ztesch)
(subi b 1) ;one more, bunkie
ztesch
(movem b inwords)
(move b inpointtem)
(movem b inpoint)
(skipe 0 withinrov)
(setom 0 delayedsexp)
(setzm 0 mailinp)
(tlne tt short-bit) ;short?
(jrst 0 tshort)
(pushj p transfer-buffer)
(movei a 'sexps)
(popj p)
tshort (pushj p transfer-short)
(movei a 'sexps)
(popj p)
initiate(movei a 'initiate)
(setzm 0 mailinp)
(popj p)
readonlyvars
(movei tt rovmail)
(movem tt transfer-spot)
(movei tt rovmailblksize)
(movem tt transfer-size)
(move a (+ imailbox 2)) ;number of bytes
(hlrem a rinbytes)
(movem a inwords)
(move a irovpointtem)
(movem a irovpoint)
(setzm 0 mailinp)
(move tt (+ imailbox 1)) ;type bits
(tlne tt short-bit) ;short?
(jrst 0 rtshort)
(pushj p transfer-buffer)
(movei a 'readonlyvars)
(popj p)
rtshort (pushj p transfer-short)
(movei a 'readonlyvars)
(popj p)
interrupt
(movei a 'interrupt)
(setzm 0 mailinp)
(popj p)
explicit-eof
(setom 0 explicit-eof)
(movei a 'eof)
(popj p)
ok
(movei a 'ok)
(setzm 0 mailinp)
(popj p)
kill
(calli 1 12) ;kill self
;;; Wait Mail
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))
em:wait-mail
(setzm 0 tyi-inited)
(skipe 0 tyop)
(pushj p force2)
wm6 (skipn 0 (special -em:queue-))
(jrst 0 wm7)
(movei t wm2)
(jrst 0 wm4)
wm7 (skipe 0 (special -em:mail-input-buffer-dry-handler-))
(pushj p em:call-handler)
wm1
(mail 1 imailbox) ;WRCV
(setom 0 newwrcv)
wm2 (hlrz tt imailbox) ;get EPR half
(caie tt epr) ;is it EPR (in sixbit)?
(jrst 0 wm6)
(hrrz tt imailbox) ;get the jobnum
(skipg 0 ijobnum)
(pushj p setjob)
(came tt ijobnum) ;correct one?
(jrst 0 wm6)
wm3
(setom 0 mailinp) ;mail now in
(movei a 't)
(popj p)
wm4 (movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(call 0 'em:get-queue)
(hrlz tt 0 a) ;address of mailbox
(hrri tt imailbox)
(blt tt (+ imailbox (- mlblksize 1))) ;transfer it
(move tt (+ imailbox 1))
(tlne tt short-bit)
(skipa)
(pushj p wm8)
(setom 0 tyi-inited) ;ready to read
(hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(jrst 0 0 t)
;(entry wm8 subr)
wm8 (pushj p zinmail)
(call 0 'em:get-lqueue)
(setom 0 lqp) ;got queued mail already
(move a 0 a)
(move b a)
(aos 0 a)
(hrlz tt a)
(hrri tt inmail)
(movn b 0 b)
(addi b inmail)
(sos 0 b)
(blt tt 0 b) ;transfer it
(popj p)
;;; Validate mail in tt, via jsp t
validate-mail
(push fxp tt)
; (pushj p pushtt1)
(hlrzs 0 tt)
(caie tt epr) ;is it EPR (in sixbit)?
(jrst 0 vm1)
(hrrz tt 0 fxp) ;get the jobnum
(camn tt ijobnum) ;correct one?
(aos 0 t)
vm1
(pop fxp tt)
; (pushj p poptt1)
(jrst 0 0 t)
;;; Mask Routines
(entry em:mask-off subr)
(args em:mask-off (nil . 0))
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:turn-mask-off subr)
(args em:turn-mask-off (nil . 0))
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:mask-on subr)
(args em:mask-on (nil . 0))
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(movei a 't)
(popj p)
em:call-handler
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(move a (special -em:mail-input-buffer-dry-handler-))
(callf 0 0 1)
(hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(skipn 0 delayedsexp)
(popj p)
(sub p (% 0 0 1 1))
(jrst 0 wm2)
;;; Mail SFA
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
(movei a 0 b) ;operation type ignore the object
(caie a 'which-operations)
(jrst 0 t1)
;;; terpri operation flushed
(movei a '(tyi tyo force-output untyi charpos linel ;terpri
force-readonly-message send-lines report-send-lines
ttyint))
(popj p)
t1 (cain a 'tyi) ;tyi?
(jrst 0 em:mail-tyi)
(cain a 'tyo) ;tyo?
(jrst 0 em:mail-tyo)
;;; terpri operation flushed
; (cain a 'terpri)
; (jrst 0 em:terpri)
(cain a 'force-output) ;force output?
(jrst 0 em:mail-force-output)
(cain a 'untyi) ;untyi?
(jrst 0 em:mail-untyi)
(cain a 'charpos)
(jrst 0 em:mail-charpos)
(cain a 'linel)
(jrst 0 em:mail-linel)
(cain a 'send-lines)
(jrst 0 isend-lines)
(cain a 'report-send-lines)
(jrst 0 report-send-lines)
(cain a 'force-readonly-message)
(jrst 0 em:force-readonly-message)
(cain a 'ttyint)
(jrst 0 em:ttyint1)
(movei a 'nil)
(popj p)
(entry em:mail-charpos subr)
(args em:mail-charpos (nil . 0))
em:mail-charpos
(skipn 0 c)
(jrst 0 g2)
(hrrz a c)
(move c 0 a)
(movem c charpos)
(popj p)
g2 (move tt charpos)
(jrst 0 fix1)
em:mail-linel
(skipn 0 c)
(jrst 0 g3)
(hrrz a c)
(movem a (special -em:linel-))
(popj p)
g3 (move a (special -em:linel-))
(popj p)
isend-lines
(movem c send-lines)
(move c @ c)
(movem c skipp)
(movem c vsend-lines)
(movei a 't)
(popj p)
report-send-lines
(move a send-lines)
(popj p)
(entry em:init-send-lines subr)
(args em:init-send-lines (nil . 0))
(movei a noutbytes)
(movem a outbytes)
(movei a nrovbytes)
(movem a rovbytes)
(movei tt 0)
(movem tt vsend-lines)
(movem tt skipp)
(movei a 'NIL)
(movem a send-lines)
(popj p)
em:terpri
(setzm 0 forcedp)
(setom 0 tyop)
(movei a cr)
(pushj p tyo1)
(movei a lf)
(jrst 0 tyo1)
em:ttyint1
(move a c)
(jcall 1 'em:ttyint)
;;; Tyi
(entry em:mail-tyi subr)
em:mail-tyi
(skipe 0 explicit-eof)
(jrst 0 eeof)
(movem c eofchar)
(skipe 0 untyif)
(jrst 0 untyi2)
(skipn 0 tyi-inited) ;not inited?
(pushj p real-mail-refresh)
ityi (skipe 0 inbytes) ;and nothing left?
(jrst 0 tyi1)
(skipe 0 (special -em:filemode-)) ;in special file mode?
(jrst 0 reof)
tyi2 (pushj p mail-refresh)
tyi1 (aosle 0 inbytes)
(pushj p mail-refresh)
inmailok
(setzm 0 newwrcv)
(ildb tt inpoint) ;get byte
(trne tt cntrl-bit)
(jrst 0 pondercntrl)
(jrst 0 fix1) ;what a bum!
em:mail-untyi
(aos 0 untyif)
(move b untyipdl)
(push b c)
(movem b untyipdl)
(popj p)
untyi2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
eeof (setzm 0 explicit-eof)
reof
(move a eofchar)
(sub p (% 0 0 1 1))
(popj p)
pondercntrl
(trnn tt meta-bit) ;foo it was control-meta
(jrst 0 tyi3)
(jrst 0 fix1) ;what a bum!
tyi3 (caie tt ccntrlg) ;↑G
(cain tt cntrlg) ;↑g
(jrst 0 ↑Ghandler)
(caie tt ccntrlx) ;↑X
(cain tt cntrlx) ;↑x
(jrst 0 ↑Xhandler)
(movei tt 0 tt)
(jsp t fxcons)
(call 1 'em:control-dispatch)
(popj p)
↑Xhandler
(movei t em:mail-tyi)
(push p t)
(push p (% 0 0 'quit))
(movni t 1)
(jcall 16 'error)
↑Ghandler
(pushj p em:init)
(call 0 '↑G)
(entry em:messagep subr)
(skipe 0 tyi-inited)
(jrst 0 true)
(skipe 0 (special -em:queue-))
(jrst 0 true)
(mail 3)
(jrst 0 false)
(jrst 0 true)
;;; Tyo
(entry em:mail-tyo subr)
em:mail-tyo
(setzm 0 forcedp)
(setom 0 tyop)
(move a @ c)
(caie a cr)
(cain a lf)
(skipa)
(setom 0 noncrlf) ;means a non crlf char has been sent
tyo1 (pushj p ucharpos) ;update charpos
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p cmail-sendit)
(caie a lf)
(jrst 0 true)
forceit
(skipn 0 noncrlf)
(jrst 0 true) ;only crlf's so far
(skipn 0 send-lines) ;if T then just return
(jrst 0 fmail-sendit)
(movei tt 't)
(camn tt send-lines)
(jrst 0 true)
(sosle 0 skipp) ;ready to do it?
(jrst 0 true)
(jrst 0 fmail-sendit)
;;; special entry for Refresh case only
force2 (skipe 0 send-lines) ;if T then just return
(popj p)
(jrst 0 fmail-sendit)
ucharpos
(caie a cr) ;cr
(jrst 0 uchrp1)
(setzm 0 charpos)
(popj p)
uchrp1 (cain a bs)
(jrst 0 adjstbs)
(cain a tab) ;tab
(jrst 0 adjstab)
(aos 0 charpos)
(popj p)
adjstab (move tt charpos)
(idivi tt 8.)
(aos 0 tt)
(imuli tt 8.)
(movem tt charpos)
(popj p)
adjstbs (aos 0 charpos)
(popj p)
;;; Force Output
fmail-sendit
(setom 0 forcedp)
(setz b)
(jrst 0 mail-sendit)
cmail-sendit
(movei b cont-bit)
(jrst 0 mail-sendit)
em:mail-force-output
(entry em:mail-force-output subr)
(skipe 0 forcedp)
(jrst 0 true)
(setz b) ;continuation
mail-sendit
(setzm 0 noncrlf)
(setzm 0 charpos)
(setzm 0 tyop)
(move a vsend-lines)
(movem a skipp)
(setz t)
(skipe 0 (special -em:silence-))
(jrst 0 skipit)
(hrlzi a omailbox)
(hrri a (+ omailbox 1))
(setzm 0 omailbox)
(blt a (+ omailbox (- mlblksize 1))) ;zero it
(movei a noutbytes)
(sub a outbytes)
(movei t 1) ;1 in t means long
(caile a maxshort) ;short enough
(jrst 0 send-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt outmail)
(hrri tt (+ omailbox 3))
(blt tt (+ omailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
send-message
(hrl tt b) ;swap
(hrri tt sexp-type)
(skipe 0 (special -em:ecommands-))
(hrri tt ecommand-type)
(movem tt (+ omailbox 1))
(movns 0 a)
(hrlzm a (+ omailbox 2))
(movei a outmail)
(hrrm a (+ omailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a omailbox)
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(movem t sav)
(mail 3) ;shit, mail arrived and it might be long!
(mail 5 ojobnum) ;mail it
(jsp tt wait-for-clear)
(move t sav)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
skipit (setzm 0 (special -em:silence-))
(move a outpointtem) ;setup output byte count
(movem a outpoint)
(movei a noutbytes)
(movem a outbytes)
(jumpe t sm2) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
sm2 (hrlzi a outmail)
(hrri a (+ outmail 1))
(setzm 0 outmail)
(blt a (+ outmail (- rdblk 1))) ;zero it
(jrst 0 true)
;;; Message Align
;;; Routine to get to a buffer from E with not all <cr>s in it
(entry em:message-align subr)
(args em:message-align (nil . 0))
em:message-align
(skipe 0 newwrcv)
(jrst 0 true)
(move tt inpoint) ;copy of byte pointer
(move t inbytes)
filalgn2
(aosle 0 t)
(jrst 0 filalgn1)
(setzm 0 newwrcv)
(ildb a tt)
(skipn 0 a)
(jrst 0 alnxtx)
(caie a tab)
(cain a space)
(jrst 0 alnxtx)
(caie a cr) ;a cr?
(cain a lf) ;a lf?
(skipa)
(jrst 0 true)
alnxtx (ibp 0 inpoint)
(aos 0 inbytes)
(jrst 0 filalgn2)
filalgn1
(pushj p mail-refresh)
(move tt inpoint)
(move t inbytes)
(popj p)
;;; Mail Refresh
;;; This routine gets fresh mail to initialize the reader
mail-refresh
real-mail-refresh
(aos 0 critical)
(722←33 0 mailint) ;imskcl
mr2
mr3 (pushj p em:wait-mail) ;wait for response
(pushj p em:process-mail) ;get the mail
(caie a 'sexps)
(jrst 0 mr3)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
;;; Transfer Buffer
;;; This routine does a jobread into the right spot.
;(entry tb subr)
transfer-buffer
(skipe 0 lqp) ;queued mail read already?
(jrst 0 tb1)
(skipe 0 (special -em:queue-))
(jrst 0 queue-stuff)
(setom 0 tyi-inited) ;ready to read
(move a transfer-spot)
(hrrzm a (+ jobread 2))
(pushj p zinmail)
(move a (+ imailbox 2))
(hrl a inwords)
(movem a (+ jobread 1))
(movei tt jobread)
(calli tt 400050) ;jobrd
(jrst 0 false)
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(pushj p send-ok)
(setzm 0 lqp)
(skipe 0 contp)
(jrst 0 queue-stuff2)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
tb1 (setzm 0 lqp)
(popj p)
transfer-short
(pushj p zinmail)
(hrlzi a (+ imailbox 3)) ;move from here
(hrr a transfer-spot) ;to here
(move tt transfer-spot)
(addi tt (- mlblksize 1))
(blt a 0 tt) ;transfer 29
(setom 0 tyi-inited) ;ready to read
(popj p)
zinmail
(hrlz a transfer-spot)
(move tt transfer-spot)
(aos 0 tt)
(hrr a tt)
(setzm 0 @ transfer-spot)
(move tt transfer-spot)
(add tt transfer-size)
(blt a -1 tt)
(popj p)
;(entry qs subr)
queue-stuff
(aos 0 critical)
(722←33 0 mailint) ;imskcl
queue-stuff2
(push fxp tt)
; (pushj p pushtt2)
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
zt4
(call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
(skipn 0 mailinp) ;already wrcv'd it?
(jrst 0 zt5)
(movei tt imailbox)
(jrst 0 zt9)
zt5 ;(mail 2 0 tt) ;mail here so soon?
(mail 1 0 tt) ;get mail
zt9 (push fxp tt)
;zt9 (pushj p pushtt3)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 zt6)
(pop fxp tt)
; (pushj p poptt3)
(move t 1 tt) ;type bits
(cain t interrupt-type)
(jrst 0 punt1)
(cain t kill-type)
(calli 1 12) ;kill self
(push fxp t)
; (pushj p pusht)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
; (pushj p popt)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 zt7)
(setom 0 lqp)
(jrst 0 zt8)
zt6 (pop fxp tt)
;zt6 (pushj p poptt3)
(jrst 0 zt5)
zt7 (setom 0 contp)
(movem t 1 tt)
(jrst 0 zt4)
zt8 (hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(pop fxp tt)
; (pushj p poptt2)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
;(entry eb subr)
enqueue-buffer
(push fxp tt)
; (pushj p pushtt4)
(hrrz tt 0 fxp)
(move a 2 tt) ;address in E of buffer
(hrrzm a (+ ljobread 1))
(hlre tt a) ;-number of bytes
(idivi tt 4) ;-number of words
(jumpe d zt1)
(subi tt 1) ;one more, bunkie
zt1
(hrlm tt (+ ljobread 1))
(movns 0 tt)
(jsp t fxcons)
(call 1 'em:add-lqueue)
(hrrz a 0 a) ;address of mailbox
(hlre tt (+ ljobread 1))
(movem tt 0 a)
(aos 0 a)
(hrrzm a (+ ljobread 2))
(movei tt ljobread)
(calli tt 400050) ;jobrd
(jrst 0 pfxpfalse)
(pop fxp tt)
; (pushj p poptt4)
(jrst 0 send-ok)
punt1 (setzm 0 1 tt)
(move d t)
(pop fxp tt)
(pushj p procint)
(jrst 0 zt4)
;;; Clear Input
(entry em:clear-input subr)
(args em:clear-input (nil . 0))
(setzm 0 lqp)
(setzm 0 critical)
(setzm 0 tyop)
(setzm 0 forcedp)
(setzm 0 noncrlf)
(setzm 0 untyif)
(setzm 0 inbytes)
(setzm 0 rinbytes)
(move a temuntyipdl)
(movem a untyipdl)
(setom 0 explicit-eof)
(setzm 0 mailinp)
(setzm 0 tyi-inited)
(pushj p zinmail)
(movei a 't)
(popj p)
;;; Wait OK
;(entry wait-ok subr)
wait-ok
(aos 0 critical)
(722←33 0 mailint) ;imskcl
wo2 (mail 1 imailbox) ;WRCV
(move tt (+ imailbox 1))
(hrrzs 0 tt) ;flush short?
(caie tt ok-type)
(jrst 0 wo1)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 true)
wo1
(push fxp tt)
; (pushj p pushtt5)
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(call 0 'em:add-queue)
(move a 0 a)
(move tt a)
(hrli a imailbox)
(move b tt)
(addi b (- mlblksize 1))
(blt a 0 b)
(jrst 0 zt19)
zt14 (call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
zt15 ;(mail 2 0 tt) ;mail here so soon?
(mail 1 0 tt) ;get mail
(push fxp tt)
; (pushj p pushtt6)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 zt16)
(pop fxp tt)
; (pushj p poptt6)
zt19 (move t 1 tt) ;type bits
(cain t interrupt-type)
(jrst 0 punt2)
(cain t kill-type)
(calli 1 12)
(cain t ok-type)
(jrst 0 zt18)
(push fxp t)
; (pushj p pusht)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
; (pushj p popt)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 zt17)
(setom 0 lqp)
(jrst 0 zt14)
zt16 (pop fxp tt)
;zt16 (pushj p poptt6)
(jrst 0 zt14)
zt17 (setom 0 contp)
(movem t 1 tt)
(jrst 0 zt14)
zt18 (hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(pop fxp tt)
; (pushj p poptt5)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 true)
punt2 (setzm 0 1 tt)
(move d t)
(pop fxp tt)
(pushj p procint)
(jrst 0 zt14)
;;; Send Simple Message
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 1))
(cain a 'ok)
(jrst 0 ok-message)
(cain a 'initiate)
(jrst 0 initiate-message)
(cain a 'hold-it)
(jrst 0 hold-it-message)
(cain a 'eof)
(jrst 0 eof-message)
(movei a 'Invalid-message)
(popj p)
eof-message
(movei a explicit-eof-type)
(jrst 0 send-simple-message)
initiate-message
(movei a initiate-type)
(jrst 0 send-simple-message)
ok-message
(movei a ok-type)
(jrst 0 send-simple-message)
hold-it-message
(movei a 102)
(movem a (+ omailbox 2))
(movei a interrupt-type)
send-simple-message
(movem a (+ omailbox 1))
(move b thisjob)
(hrli b epr)
(movem b omailbox)
(jfcl)
(mail 5 ojobnum)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
; (entry wfc subr)
wait-for-clear
(mail 3)
(jrst 0 wfc1) ;nothing there?
(aos 0 critical)
(722←33 0 mailint)
(pushj p queue-stuff2)
wfc1 (setz a)
(calli a 31)
(jrst 0 -3 tt)
;wait-for-stuff
;wfs1 (mail 3)
; (jrst 0 wfs2) ;nothing there?
; (jrst 0 -3 t)
;wfs2 (setz a)
; (calli a 31)
; (jrst 0 wfs1)
;;; Em:init
(entry em:init subr)
(args em:init (nil . 0))
em:init
(setzm 0 (special -em:queue-))
(setzm 0 lqp)
(setzm 0 newwrcv)
(setzm 0 withinrov)
(setzm 0 delayedsexp)
(movei tt inmail)
(movem tt transfer-spot)
(movei tt blksize)
(movem tt transfer-size)
(movei tt noutbytes)
(movem tt outbytes)
(movei tt nrovbytes)
(movem tt rovbytes)
(calli tt #o30)
(movem tt thisjob)
(jrst 0 fix1)
em:get-terminal
(movei tt #o236)
(calli tt #o33) ;jobtlin
(add tt ijobnum) ;add jobnum
(calli tt #o33) ;get terminal line number
(hrrzm tt termlin) ;save it
(popj p)
(entry em:warn subr)
(args em:warn (nil . 1))
(call 1 'exploden)
(movei tt 500.)
(move t mpointtem)
(move a 0 a)
wloop (hlrz b a)
(move b 0 b)
(idpb b t)
(sosge 0 tt)
(jrst 0 wdone)
(skipn 0 b)
(jrst 0 wdone)
(move a 0 a)
(jrst 0 wloop)
wdone
(move tt termlin)
(calli tt #o400111) ;beep it
(movei a dmess)
(movem a (+ termlin 1))
(movei tt termlin)
(calli tt #o400047)
(jrst 0 false)
(jrst 0 true)
(popj p)
;;; Send OK
send-ok
(movei a ok-type)
(movem a (+ o2mailbox 1))
(move b thisjob)
(hrli b epr)
(movem b o2mailbox)
(jfcl)
(mail 5 o2jobnum)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
;;; Em:eval-protect
(entry em:eval-protect subr)
(args em:eval-protect (nil . 0))
(movei a 'em:sail-mail-interrupt-handler)
(movem a (special si:sail-mail-service))
(movei a 't)
(popj p)
(entry em:eval-unprotect subr)
(args em:eval-unprotect (nil . 0))
(movei a 'nil)
(movem a (special si:sail-mail-service))
(popj p)
;;; Mail queue
(entry em:business-address subr)
(args em:business-address (nil . 1))
(hrrz a 0 a) ;get address
(hrrz tt 0 a)
(hrrzi tt 4 tt) ;business address
(jrst 0 fix1) ;return it
(entry em:mail-interrupt-handler subr)
(args em:mail-interrupt-handler (nil . 1))
(mail 3)
(jrst 0 false)
(aos 0 critical)
(722←33 0 mailint) ;imskcl
mi4 (call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
mi5 (mail 1 0 tt) ;get mail
(push fxp tt)
; (pushj p pushtt7)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 mi6)
(pop fxp tt)
; (pushj p poptt7)
(move t 1 tt) ;type bits
(cain t interrupt-type)
(jrst 0 mi8)
(push fxp t)
; (pushj p pusht)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
; (pushj p popt)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 mi7)
(setom 0 lqp)
(jrst 0 mi8)
mi6 (pop fxp tt)
;mi6 (pushj p poptt7)
(jrst 0 mi5)
mi7 (setom 0 contp)
(movem t 1 tt)
(jrst 0 mi4)
mi8 (hrrz d 1 tt) ;type
(sosg 0 critical)
(721←33 0 mailint) ;imskst
procint
(cain d kill-type)
(calli 1 12) ;suicide
(caie d interrupt-type) ;control char?
(jrst 0 true) ;no, just report the incident
(move tt 2 tt)
(tro tt #o200) ;controlify it
(jsp t fxcons)
(jcall 1 'em:control-dispatch)
;;; Readonly Variables
;;; Routines for obtaining the values of readonly variables
(entry em:readonly-init subr)
(args em:readonly-init (nil . 0))
(aos 0 critical)
(722←33 0 mailint) ;imskcl
;inited mailinp
;0 0 ?
;0 -1 in but not inited, must refresh
;-1 0 ok
;-1 -1 contradiction
(setom 0 withinrov)
(move tt tyop)
(movem tt otyop)
(move tt tyi-inited)
(movem tt otyi-inited)
(move tt transfer-spot)
(movem tt otransfer-spot)
(move tt transfer-size)
(movem tt otransfer-size)
(setzm 0 tyop)
(jrst 0 true)
(entry em:make-sixbit subr)
(args em:make-sixbit (nil . 1))
;;; Takes list of variables and returns an alist of variable-value pairs
sixmak (movei b '6) ;direct lift from faslap
(call 2 'pnget)
(hlrz a 0 a)
(move tt 0 a)
(idpb tt rovpoint) ;put it there
(sosle 0 rovbytes) ;ready to send?
(jrst 0 fix1) ;return fixnum
;falls through
;;; Read only variable mail message
(entry em:force-readonly-message subr)
(args em:force-readonly-message (nil . 0))
em:force-readonly-message
(setzm 0 tyi-inited)
(movei a rovmail) ;address of buffer
(movem a (+ omailbox 2))
(movei a nrovbytes)
(sub a rovbytes)
(movei t 1) ;1 in t means long
(caile a rovmaxshort) ;short enough
(jrst 0 rovsend-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt rovmail)
(hrri tt (+ omailbox 3))
(blt tt (+ omailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
rovsend-message
(hrl tt b) ;swap
(hrri tt readonlyvar-type)
(movem tt (+ omailbox 1))
(movns 0 a)
(hrlzm a (+ omailbox 2))
(movei a rovmail)
(hrrm a (+ omailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a omailbox)
(mail 3)
(mail 5 ojobnum) ;mail it
(jsp tt wait-for-clear)
(skipa)
(jrst 0 wrongj)
(hrlzi a rovmail) ;zeros output buffer
(hrri a (+ rovmail 1))
(setzm 0 rovmail)
(blt a (+ rovmail (- rovmailblksize 1))) ;zero it
(move a rovpointtem) ;setup output byte count
(movem a rovpoint)
(movei a nrovbytes)
(setzm 0 rinbytes)
(movem a rovbytes)
(jumpe t true) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mail-type)
(came a 'ok)
(jrst 0 false)
(jrst 0 true)
(entry em:get-next-readonly subr)
(args em:get-next-readonly (nil . 0))
(skipn 0 tyi-inited)
(pushj p rovmail-refresh)
(aosle 0 rinbytes)
(jrst 0 rovdone)
(setzm 0 newwrcv)
(ildb tt irovpoint) ;get it
(jsp t fxcons)
(push fxp a) ;save it
(aosle 0 rinbytes)
(jrst 0 (- rovdone 1))
(ildb tt irovpoint)
(jsp t fxcons)
(pop fxp b)
(jcall 2 'xcons)
(sub fxp (% 0 0 1 1))
rovdone
(move tt otyi-inited)
(movem tt tyi-inited)
(move tt otransfer-spot)
(movem tt transfer-spot)
(move tt otransfer-size)
(movem tt transfer-size)
(move tt otyop)
(movem tt tyop)
(setzm 0 withinrov)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(seto tt)
(jrst 0 fix1)
rovmail-refresh
rm2 (pushj p em:wait-mail)
(pushj p em:process-mail)
(cain a 'readonlyvars)
(popj p)
(jrst 0 rm2)
;;; Random debugging stuff
;;; Prints the char on FXP with outchr
;pushtt1
; (push fxp tt)
; (movei tt 101)
; (ttyuuo 1 tt)
; (aos 0 ptt1)
; (move tt 0 fxp)
; (popj p)
;poptt1
; (movei tt 141)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt1)
; (popj p)
;pushtt2
; (push fxp tt)
; (movei tt 102)
; (ttyuuo 1 tt)
; (aos 0 ptt2)
; (move tt 0 fxp)
; (popj p)
;poptt2
; (movei tt 142)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt2)
; (popj p)
;pushtt3
; (push fxp tt)
; (movei tt 103)
; (ttyuuo 1 tt)
; (aos 0 ptt3)
; (move tt 0 fxp)
; (popj p)
;poptt3
; (movei tt 143)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt3)
; (popj p)
;pushtt4
; (push fxp tt)
; (movei tt 104)
; (ttyuuo 1 tt)
; (aos 0 ptt4)
; (move tt 0 fxp)
; (popj p)
;poptt4
; (movei tt 144)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt4)
; (popj p)
;pushtt5
; (push fxp tt)
; (movei tt 105)
; (ttyuuo 1 tt)
; (aos 0 ptt5)
; (move tt 0 fxp)
; (popj p)
;poptt5
; (movei tt 145)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt5)
; (popj p)
;pushtt6
; (push fxp tt)
; (movei tt 106)
; (ttyuuo 1 tt)
; (aos 0 ptt6)
; (move tt 0 fxp)
; (popj p)
;poptt6
; (movei tt 146)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt6)
; (popj p)
;pushtt7
; (push fxp tt)
; (movei tt 107)
; (ttyuuo 1 tt)
; (aos 0 ptt7)
; (move tt 0 fxp)
; (popj p)
;poptt7
; (movei tt 147)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt7)
; (popj p)
;popt
; (movei t 22)
; (ttyuuo 1 t)
; (pop fxp t)
; (sos 0 pt)
; (popj p)
;ptt1 (0)
;ptt2 (0)
;ptt3 (0)
;ptt4 (0)
;ptt5 (0)
;ptt6 (0)
;ptt7 (0)
;pt (0)
;;report
; (movem tt sav)
; (pop fxp tt)
; (ttyuuo 1 tt)
; (move tt sav)
; (popj p)
sav (0)
;;; Storage for Mail routines
critical (0)
delayedsexp (0) ;states whether an sexpr came in during
;an input buffer dry demon execution
newwrcv (0) ;is not 0 when a WRCV has been done without any
;ilbp being done
lqp (0) ;queued long mail read
contp (0) ;continuation bit
withinrov (0)
transfer-spot (0)
otransfer-spot (0)
transfer-size (0)
otransfer-size (0)
svdacs (block 10.)
send-lines (0)
noncrlf (0)
vsend-lines (0)
skipp (0)
tyop (0)
otyop (0)
forcedp (0) ;output already forced
inwords (0) ;number of words to input via jobread
explicit-eof (-1) ;nil
mailint (4000000000)
ijobnum (-1)
(0 0 imailbox)
ojobnum (-1)
(0 0 omailbox)
o2jobnum(-1)
(0 0 o2mailbox)
imailbox (block mlblksize) ;mail
omailbox (block mlblksize) ;mail
o2mailbox (block mlblksize) ;mail
inmail (block blksize) ;text
outmail (block blksize) ;text
rovmail (block rovmailblksize)
stack (block 20)
untyipdl (777760←22 0 stack)
temuntyipdl (777760←22 0 stack)
untyif (0)
termlin (0)
(0 0 dmess)
dmess (block 100.)
(0)
mpointtem (700←22 0 (- dmess 1))
inpoint (1100←22 0 (- inmail 1))
inpointtem (1100←22 0 (- inmail 1))
irovpoint (4400←22 0 (- rovmail 1))
irovpointtem (4400←22 0 (- rovmail 1))
rinbytes (0)
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
rovpoint (4400←22 0 (- rovmail 1))
rovpointtem (4400←22 0 (- rovmail 1))
outchartem (700←22 0 (+ omailbox 2))
outbytes (0 0 noutbytes)
rovbytes (0 0 nrovbytes)
mailinp (0) ;-1 means in
charpos (0)
thisjob (0)
tyi-inited (0) ;ready to read. 0 = nil, -1 = t
otyi-inited (0) ;ready to read. 0 = nil, -1 = t
eofchar (0) ;eof char
jobread (0)
(0)
(0 0 inmail)
ljobread(0)
(0)
(0 0 inmail)
()
(or (and (boundp 'em:no-init) em:no-init)
(progn
(em:mail-interface-initialize)))